home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmplet.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
10KB
|
244 lines
;;; CMPLET Let and Let*.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(si:putprop 'let 'c1let 'c1special)
(si:putprop 'let 'c2let 'c2)
(si:putprop 'let* 'c1let* 'c1special)
(si:putprop 'let* 'c2let* 'c2)
(defun c1let (args &aux (info (make-info))
(forms nil) (vars nil) (vnames nil)
ss is ts body other-decls
(*vars* *vars*))
(when (endp args) (too-few-args 'let 1 0))
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
(c1add-globals ss)
(dolist** (x (car args))
(cond ((symbolp x)
(let ((v (c1make-var x ss is ts)))
(push x vnames)
(push v vars)
(push (default-init (var-type v)) forms)))
(t (cmpck (not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
"The variable binding ~s is illegal." x)
(let ((v (c1make-var (car x) ss is ts)))
(push (car x) vnames)
(push v vars)
(push (if (endp (cdr x))
(default-init (var-type v))
(and-form-type (var-type v)
(c1expr* (cadr x) info)
(cadr x)))
forms)))))
(dolist* (v (reverse vars)) (push v *vars*))
(check-vdecl vnames ts is)
(setq body (c1decl-body other-decls body))
(add-info info (cadr body))
(setf (info-type info) (info-type (cadr body)))
(dolist** (var vars) (check-vref var))
(list 'let info (reverse vars) (reverse forms) body)
)
(defun c2let (vars forms body
&aux (block-p nil) (bindings nil)
(*unwind-exit* *unwind-exit*)
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
(declare (object block-p))
(dolist** (var vars)
(let ((kind (c2var-kind var)))
(declare (object kind))
(if kind
(let ((cvar (next-cvar)))
(setf (var-kind var) kind)
(setf (var-loc var) cvar)
(wt-nl)
(unless block-p (wt "{") (setq block-p t))
(wt (rep-type kind) "V" cvar ";"))
(setf (var-ref var) (vs-push)))))
(do ((vl vars (cdr vl)) (fl forms (cdr fl)) (prev-ss nil))
((endp vl))
(declare (object vl fl))
(let ((form (car fl)) (var (car vl)))
(declare (object form var))
(case (var-kind var)
((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
(let ((*value-to-go* (list 'var var nil))) (c2expr* form)))
(otherwise
(case (car form)
(LOCATION
(if (can-be-replaced var body)
(progn (setf (var-kind var) 'REPLACED)
(setf (var-loc var) (caddr form)))
(push (list var (caddr form)) bindings)))
(VAR
(let ((var1 (caaddr form)))
(declare (object var1))
(cond ((or (args-info-changed-vars var1 (cdr fl))
(and (member (var-kind var1) '(SPECIAL GLOBAL))
(member (var-name var1) prev-ss)))
(let ((*value-to-go* (list 'vs (var-ref var))))
(c2expr* form))
(push (list var) bindings))
((and (can-be-replaced var body)
(member (var-kind var1)
'(LEXICAL REPLACED OBJECT))
(null (var-ref-ccb var1))
(not (member var1 (info-changed-vars
(cadr body)))))
(setf (var-kind var) 'REPLACED)
(setf (var-loc var)
(case (var-kind var1)
(LEXICAL (list 'vs (var-ref var1)))
(REPLACED (var-loc var1))
(OBJECT (list 'cvar (var-loc var1)))
(otherwise (baboon)))))
(t (push (list var
(list 'var var1 (cadr (caddr form))))
bindings)))))
(t (let ((*value-to-go* (list 'vs (var-ref var))))
(c2expr* form))
(push (list var) bindings))
)))
(when (eq (var-kind var) 'SPECIAL) (push (var-name var) prev-ss))
))
(dolist* (binding (reverse bindings))
(if (cdr binding)
(c2bind-loc (car binding) (cadr binding))
(c2bind (car binding))))
(c2expr body)
(when block-p (wt "}"))
)
(defun c1let* (args &aux (forms nil) (vars nil) (vnames nil)
ss is ts body other-decls
(info (make-info)) (*vars* *vars*))
(when (endp args) (too-few-args 'let* 1 0))
(multiple-value-setq (body ss ts is other-decls) (c1body (cdr args) nil))
(c1add-globals ss)
(dolist** (x (car args))
(cond ((symbolp x)
(let ((v (c1make-var x ss is ts)))
(push x vnames)
(push (default-init (var-type v)) forms)
(push v vars)
(push v *vars*)))
((not (and (consp x) (or (endp (cdr x)) (endp (cddr x)))))
(cmperr "The variable binding ~s is illegal." x))
(t (let ((v (c1make-var (car x) ss is ts)))
(push (car x) vnames)
(push (if (endp (cdr x))
(default-init (var-type v))
(and-form-type (var-type v)
(c1expr* (cadr x) info)
(cadr x)))
forms)
(push v vars)
(push v *vars*)))))
(check-vdecl vnames ts is)
(setq body (c1decl-body other-decls body))
(add-info info (cadr body))
(setf (info-type info) (info-type (cadr body)))
(dolist** (var vars) (check-vref var))
(list 'let* info (reverse vars) (reverse forms) body)
)
(defun c2let* (vars forms body
&aux (block-p nil)
(*unwind-exit* *unwind-exit*)
(*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
(declare (object block-p))
(dolist** (var vars)
(let ((kind (c2var-kind var)))
(declare (object kind))
(when kind
(let ((cvar (next-cvar)))
(setf (var-kind var) kind)
(setf (var-loc var) cvar)
(wt-nl)
(unless block-p (wt "{") (setq block-p t))
(wt (rep-type kind) "V" cvar ";")))))
(do ((vl vars (cdr vl))
(fl forms (cdr fl)))
((endp vl))
(declare (object vl fl))
(let ((form (car fl)) (var (car vl)))
(declare (object form var))
(if (member (var-kind var)
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT))
(let ((*value-to-go* (list 'var var nil)))
(c2expr* form))
(case (car form)
(LOCATION
(cond ((can-be-replaced* var body (cdr fl))
(setf (var-kind var) 'REPLACED)
(setf (var-loc var) (caddr form)))
(t (setf (var-ref var) (vs-push))
(c2bind-loc var (caddr form)))))
(VAR
(let ((var1 (caaddr form)))
(declare (object var1))
(cond ((and (can-be-replaced* var body (cdr fl))
(member (var-kind var1)
'(LEXICAL REPLACED OBJECT))
(null (var-ref-ccb var1))
(not (args-info-changed-vars var1 (cdr fl)))
(not (member var1 (info-changed-vars
(cadr body)))))
(setf (var-kind var) 'REPLACED)
(setf (var-loc var)
(case (var-kind var1)
(LEXICAL (list 'vs (var-ref var1)))
(REPLACED (var-loc var1))
(OBJECT (list 'cvar (var-loc var1)))
(otherwise (baboon)))))
(t (setf (var-ref var) (vs-push))
(c2bind-loc var
(list 'var var1 (cadr (caddr form)))))))
)
(t (setf (var-ref var) (vs-push))
(c2bind-init var form))))
))
(c2expr body)
(when block-p (wt "}"))
)
(defun can-be-replaced (var body)
(and (eq (var-kind var) 'LEXICAL)
(null (var-ref-ccb var))
(not (member var (info-changed-vars (cadr body))))))
(defun can-be-replaced* (var body forms)
(and (eq (var-kind var) 'LEXICAL)
(null (var-ref-ccb var))
(not (member var (info-changed-vars (cadr body))))
(dolist** (form forms t)
(when (member var (info-changed-vars (cadr form)))
(return nil)))
))